home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr09 / famprint.zip / FAMPRINT.BAS next >
BASIC Source File  |  1993-06-09  |  21KB  |  719 lines
  1. '
  2. '***************************************************************************
  3. '*                                                                         *
  4. '*                       FamPrint - Family Print                           *
  5. '*                          by Kent Riggins                                *
  6. '*                             Sept 1989                                   *
  7. '*                                                                         *
  8. '*  You Must start QuickBasic with the  /AH Option                         *
  9. '*                                                                         *
  10. '*                                                                         *
  11. '***************************************************************************
  12.  
  13. DECLARE SUB DoParents (VP AS INTEGER)
  14. DECLARE SUB ConnectFamily (Start AS INTEGER, Finish AS INTEGER)
  15. DECLARE SUB DoSpouses (VP AS INTEGER)
  16. DECLARE SUB ConnectSpouses (Start AS INTEGER, Last AS INTEGER)
  17. DECLARE SUB PrintLI (VP%)
  18. DECLARE SUB MakeName (RCD AS INTEGER, Nam AS STRING)
  19. DECLARE SUB PrintIt ()
  20. DECLARE SUB GenFam (RCD%, GenVar%)
  21. DECLARE SUB FindChildren (Child%)
  22. DECLARE SUB SortInd ()
  23. DECLARE SUB PrintAll ()
  24. DECLARE SUB ConvertDate (a$, year%, month%, day%, MODIFIER%, DYEAR%)
  25. DECLARE FUNCTION G2JD& (year%, month%, day%)
  26. DECLARE SUB Push (Dat%)
  27. DECLARE SUB Pop (Dat%)
  28. DECLARE SUB GetName (NAMERCD%, Name$)
  29.  
  30. PRINT "    ╔═══════════════════════════════════════════════════════╗ "
  31. PRINT "    ║                        FAMPRINT                       ║ "
  32. PRINT "    ║                  PAF to BIG Wall Chart                ║ "
  33. PRINT "    ║          (C) Copyright 1989 by Kent Riggins           ║ "
  34. PRINT "    ╚═══════════════════════════════════════════════════════╝ "
  35. PRINT
  36. PRINT " ┌─────────────────────────────────────────────────────────────┐"
  37. PRINT " │ This program is in  its first iteration....    I know       │"
  38. PRINT " │everything does not work correctly, but it is getting there. │"
  39. PRINT " │                                                             │"
  40. PRINT " │ This program prints a linked chart of everyone in your PAF  │"
  41. PRINT " │database.  One problem is that if your database is too big   │"
  42. PRINT " │for any one generation, it blows up.... another is that not  │"
  43. PRINT " │all the connecting lines are properly routed.... but like I  │"
  44. PRINT " │said above I am working on it......                          │"
  45. PRINT " └─────────────────────────────────────────────────────────────┘"
  46.  
  47. TYPE NameRecord
  48.      NLLINK      AS INTEGER
  49.      NNAME       AS STRING * 17
  50.      NRLINK      AS INTEGER
  51. END TYPE
  52.  
  53. TYPE BNameRecord
  54.      NAMEMAX     AS STRING * 11
  55.      NFIRSTDELET AS STRING * 10
  56. END TYPE
  57.  
  58. TYPE MarrRecord
  59.      MHusPtr     AS INTEGER
  60.      MWifPtr     AS INTEGER
  61.      MChildPtr   AS INTEGER
  62.      MarrDT      AS STRING * 4
  63.      MPL1        AS INTEGER
  64.      MPL2        AS INTEGER
  65.      MPL3        AS INTEGER
  66.      MPL4        AS INTEGER
  67.      MWifToHusSealDT      AS STRING * 3
  68.      MWifToHusSealTemp    AS INTEGER
  69.      MHusOtherMarrPtr     AS INTEGER
  70.      MWifOtherMarrPtr     AS INTEGER
  71. END TYPE
  72.  
  73. TYPE BMarrRecord
  74.      MarrMAX            AS STRING * 11
  75.      MarrFIRSTDELET     AS STRING * 10
  76.      XXXX               AS STRING * 7
  77. END TYPE
  78.  
  79. TYPE IndiRecord
  80.      ISUR        AS INTEGER
  81.      IG1         AS INTEGER
  82.      IG2         AS INTEGER
  83.      IG3         AS INTEGER
  84.      ITITLE      AS INTEGER
  85.      ISEX        AS STRING * 1
  86.      IBDT        AS STRING * 4
  87.      IBP1        AS INTEGER
  88.      IBP2        AS INTEGER
  89.      IBP3        AS INTEGER
  90.      IBP4        AS INTEGER
  91.      ICHD        AS STRING * 4
  92.      ICP1        AS INTEGER
  93.      ICP2        AS INTEGER
  94.      ICP3        AS INTEGER
  95.      ICP4        AS INTEGER
  96.      IDD         AS STRING * 4
  97.      IDP1        AS INTEGER
  98.      IDP2        AS INTEGER
  99.      IDP3        AS INTEGER
  100.      IDP4        AS INTEGER
  101.      IBUD        AS STRING * 4
  102.      IBU1        AS INTEGER
  103.      IBU2        AS INTEGER
  104.      IBU3        AS INTEGER
  105.      IBU4        AS INTEGER
  106.      IBAPD       AS STRING * 3
  107.      IBAPT       AS INTEGER
  108.      IEDD        AS STRING * 3
  109.      IEDT        AS INTEGER
  110.      ICTPSD      AS STRING * 3
  111.      ICTPST      AS INTEGER
  112.      IOSP        AS INTEGER
  113.      IOMP        AS INTEGER
  114.      IPMP        AS INTEGER
  115.      IIDNUM      AS STRING * 10
  116.      INPADP      AS INTEGER
  117. END TYPE
  118.  
  119. TYPE BIndiRecord
  120.      INDIVIDMAX  AS STRING * 11
  121.      IFIRSTDELET AS STRING * 10
  122.      XXXX        AS STRING * 71
  123. END TYPE
  124.  
  125. TYPE Location
  126.       Index AS STRING * 14
  127.       Gen AS INTEGER    'also used as Row
  128.       Fam AS INTEGER    'also used as Column
  129.       Birth AS DOUBLE   'also used as Line
  130.       SiblingCheck AS STRING * 1
  131.       RCD AS INTEGER
  132.       ParentFam AS INTEGER
  133.       Processed AS STRING * 1
  134. END TYPE
  135.  
  136. TYPE Pline
  137.    LRcd AS INTEGER
  138.    COL AS STRING * 50
  139.    RRcd AS INTEGER
  140.    FamCon AS STRING * 1
  141. END TYPE
  142.  
  143. DIM SHARED Head AS INTEGER, Tail AS INTEGER, LFMT AS STRING
  144. LFMT = "\                                                \\                          \\\"
  145.  
  146. CurrentGen% = 5
  147. REM $DYNAMIC
  148. DIM SHARED IND(0 TO 2000) AS Location
  149. DIM SHARED Stack%(1000), FamNum%(30)
  150. DIM SHARED LI(1 TO 2000) AS Pline
  151. DIM SHARED IPTR(2000)  AS INTEGER
  152. DIM NameR AS NameRecord, BName AS BNameRecord
  153. DIM CIndi AS IndiRecord, Tindi AS IndiRecord, BIndi  AS BIndiRecord
  154. DIM Marr AS MarrRecord, TMarr AS MarrRecord, BMarr  AS BMarrRecord
  155.  
  156. INPUT "     Enter path for input: ", fp$
  157. INPUT "     Enter path and file for output: ", outfile$
  158. OPEN fp$ + "name2.dat" FOR RANDOM AS #1 LEN = 21
  159. OPEN fp$ + "indiv2.dat" FOR RANDOM AS #2 LEN = 92
  160. OPEN fp$ + "MARR2.DAT" FOR RANDOM AS #3 LEN = 28
  161. OPEN outfile$ FOR OUTPUT AS #8
  162. GET #3, 1, BMarr
  163. MarrMAX% = VAL(MarrMAX$)
  164.  
  165. GET #2, 1, BIndi
  166. INDIVIDMAX% = VAL(BIndi.INDIVIDMAX)
  167.  
  168. Main:
  169. GOSUB Search
  170. PRINT "There are "; INDIVIDMAX%; " people in the individual file."
  171. PRINT " and "; TotalCount; " Where found!"
  172. SortInd
  173. PrintIt
  174. CLOSE ALL
  175. END
  176.  
  177. Search:
  178.   CLS
  179.   PRINT
  180.   PRINT "Enter Starting RIN:";
  181.   INPUT StartRIN%
  182.   CALL Push(StartRIN%)
  183.  
  184.   CLS
  185.   PRINT "There are "; INDIVIDMAX%; " people in the individual file."
  186.   PRINT "This may take a While...."
  187.   Done% = 1
  188.   CurrentGen% = 5
  189.   TotalCount = 0
  190.   CLS
  191.   PRINT "Searching "
  192.   DO WHILE (Done% <> 0)
  193.     CALL Pop(CurrentIndi%)
  194.     IF CurrentIndi% < 1 THEN
  195.        Done% = 0
  196.        EXIT DO
  197.     END IF
  198.     IF IND(CurrentIndi%).Processed = "Y" THEN GOTO Bottom
  199.     IND(CurrentIndi%).RCD = CurrentIndi%
  200.     LOCATE 3, 1
  201.     PRINT CurrentIndi%; "  "
  202.     TotalCount = TotalCount + 1
  203.     GET #2, (CurrentIndi% + 1), CIndi
  204.     IND(CurrentIndi%).Processed = "Y"
  205.     CALL GenFam(CurrentIndi%, 0)
  206.     CurrentGen% = IND(CurrentIndi%).Gen
  207.     CALL ConvertDate(CIndi.IBDT, year%, month%, day%, MODIFIER%, DYEAR%)
  208.     IND(CurrentIndi%).Birth = G2JD&(year%, month%, day%)
  209.    
  210.     ' Find all Spouses
  211.     IF CIndi.IOMP > 0 THEN
  212.        GET #3, (CIndi.IOMP + 1), Marr
  213.        IF CIndi.ISEX = "M" THEN
  214.           CALL GenFam(Marr.MWifPtr, 0)
  215.           CALL Push(Marr.MWifPtr)
  216.           CALL FindChildren(Marr.MChildPtr)
  217.           DO WHILE (Marr.MHusOtherMarrPtr > 0)
  218.              GET #3, (Marr.MHusOtherMarrPtr + 1), Marr
  219.              CALL GenFam(Marr.MWifPtr, 0)
  220.              CALL Push(Marr.MWifPtr)
  221.              CALL FindChildren(Marr.MChildPtr)
  222.           LOOP
  223.        ELSE
  224.           CALL GenFam(Marr.MHusPtr, 0)
  225.           CALL Push(Marr.MHusPtr)
  226.           CALL FindChildren(Marr.MChildPtr)
  227.           DO WHILE (Marr.MWifOtherMarrPtr > 0)
  228.              GET #3, (Marr.MWifOtherMarrPtr + 1), Marr
  229.              CALL GenFam(Marr.MHusPtr, 0)
  230.              CALL Push(Marr.MHusPtr)
  231.              CALL FindChildren(Marr.MChildPtr)
  232.           LOOP
  233.        END IF
  234.     END IF
  235.  
  236.     ' Find parents
  237.     IF CIndi.IPMP > 0 THEN
  238.        GET #3, (CIndi.IPMP + 1), TMarr
  239.  
  240.        ' Do Father
  241.        CALL GenFam(TMarr.MHusPtr, 1)
  242.        IF TMarr.MHusPtr > 0 THEN
  243.           IND(CurrentIndi%).ParentFam = IND(TMarr.MHusPtr).Fam
  244.        ELSE
  245.           IF TMarr.MWifPtr > 0 THEN
  246.              IND(CurrentIndi%).ParentFam = IND(TMarr.MWifPtr).Fam
  247.           END IF
  248.        END IF
  249.        CALL Push(TMarr.MHusPtr)
  250.        ' Do Mother
  251.        CALL GenFam(TMarr.MWifPtr, 1)
  252.        CALL Push(TMarr.MWifPtr)
  253.  
  254.        ' Find Brothers and sisters
  255.        IF IND(CurrentIndi%).SiblingCheck = "N" THEN
  256.           IND(CurrentIndi%).SiblingCheck = "Y"
  257.           Child% = TMarr.MChildPtr
  258.           GET #2, (Child% + 1), Tindi
  259.           DO WHILE (Child% > 0)
  260.              IND(Child%).Gen = IND(CurrentIndi%).Gen
  261.              IND(Child%).Fam = IND(CurrentIndi%).Fam
  262.              IND(Child%).SiblingCheck = "Y"
  263.              CALL Push(Child%)
  264.              Child% = Tindi.IOSP
  265.              IF Child% > 0 THEN
  266.                 GET #2, (Child% + 1), Tindi
  267.              ELSE
  268.                 EXIT DO
  269.              END IF
  270.           LOOP
  271.        END IF
  272.     END IF
  273.  
  274. Bottom:
  275.   LOOP
  276. RETURN
  277.  
  278. REM $STATIC
  279. SUB ConnectFamily (Start AS INTEGER, Finish AS INTEGER)
  280. DIM dir AS INTEGER
  281. StartLI = IND(Start).Birth  'Start Line
  282. EndLI = IND(Finish).Gen     'End Line
  283. EndCol = IND(Finish).Fam    'End Column
  284.    MID$(LI(StartLI).COL, 1, 1) = "─" '196
  285.    COL = 2
  286.    DO WHILE (MID$(LI(StartLI).COL, COL, 1) <> " " AND COL < 50)
  287.       IF MID$(LI(StartLI).COL, COL, 1) = "│" THEN '179
  288.          MID$(LI(StartLI).COL, COL, 1) = "┼" '197
  289.       END IF
  290.       MID$(LI(StartLI).COL, COL + 1, 1) = "─" '196
  291.       COL = COL + 2
  292.    LOOP
  293.    IF StartLI < EndLI THEN
  294.       dir = 1
  295.       MID$(LI(StartLI).COL, COL, 1) = "┐" '191
  296.    ELSE
  297.       MID$(LI(StartLI).COL, COL, 1) = "┘" '217
  298.       dir = -1
  299.    END IF
  300.    FOR L = (StartLI + dir) TO EndLI STEP dir
  301.      SELECT CASE MID$(LI(L).COL, COL, 1)
  302.         CASE " "
  303.            MID$(LI(L).COL, COL, 1) = "│" '179
  304.  
  305.         CASE "─" '196
  306.               MID$(LI(L).COL, COL, 1) = "┼" '197
  307.  
  308.         CASE ELSE
  309.          IF dir < 0 THEN ' ie going up
  310.            MID$(LI(L + 1).COL, COL, 1) = "┌" '218
  311.            DoneUp = 1
  312.            DO WHILE (DoneUp = 1)
  313.               COL = COL + 1
  314.               MID$(LI(L + 1).COL, COL, 1) = "─" '196
  315.               IF MID$(LI(L).COL, COL, 1) = "─" THEN '179
  316.                  MID$(LI(L + 1).COL, COL, 1) = "┘" '217
  317.                  MID$(LI(L).COL, COL, 1) = "┼" '197
  318.                  DoneUp = 0
  319.                  EXIT DO
  320.               END IF
  321.               IF MID$(LI(L).COL, COL, 1) = " " THEN '179
  322.                  MID$(LI(L + 1).COL, COL, 1) = "┘" '217
  323.                  MID$(LI(L).COL, COL, 1) = "│" '179
  324.                  DoneUp = 0
  325.                  EXIT DO
  326.               END IF
  327.            LOOP
  328.         ELSE ' going down
  329.            MID$(LI(L - 1).COL, COL, 1) = "└" '192
  330.            DoneUp = 1
  331.            DO WHILE (DoneUp = 1)
  332.               COL = COL + 1
  333.               MID$(LI(L - 1).COL, COL, 1) = "─" '196
  334.               IF MID$(LI(L).COL, COL, 1) = "─" THEN '179
  335.                  MID$(LI(L - 1).COL, COL, 1) = "┐" '191
  336.                  MID$(LI(L).COL, COL, 1) = "┼" '197
  337.                  DoneUp = 0
  338.                  EXIT DO
  339.               END IF
  340.               IF MID$(LI(L).COL, COL, 1) = " " THEN '179
  341.                  MID$(LI(L - 1).COL, COL, 1) = "┐" '191
  342.                  MID$(LI(L).COL, COL, 1) = "│" '179
  343.                  DoneUp = 0
  344.                  EXIT DO
  345.               END IF
  346.            LOOP
  347.         END IF
  348.         END SELECT
  349.  
  350.    NEXT L
  351.    IF StartLI < EndLI THEN
  352.       MID$(LI(EndLI).COL, COL, 1) = "└"  '192
  353.    ELSE
  354.       MID$(LI(EndLI).COL, COL, 1) = "┌" '218
  355.    END IF
  356.  
  357.    FOR C = (COL + 1) TO (EndCol - 1)
  358.      IF MID$(LI(EndLI).COL, C, 1) = "│" THEN '179
  359.         MID$(LI(EndLI).COL, C, 1) = "┼" '197
  360.      ELSE
  361.         MID$(LI(EndLI).COL, C, 1) = "─" '196
  362.      END IF
  363.    NEXT C
  364.    IF MID$(LI(EndLI).COL, EndCol, 1) = "┌" THEN  ' 218
  365.       MID$(LI(EndLI).COL, EndCol, 1) = "┬"  '194
  366.    ELSE
  367.       IF MID$(LI(EndLI).COL, EndCol, 1) = "└" THEN  ' 192
  368.          MID$(LI(EndLI).COL, EndCol, 1) = "┴"  '193
  369.       ELSE
  370.          MID$(LI(EndLI).COL, EndCol, 1) = "─"  '196
  371.       END IF
  372.    END IF
  373. 1
  374. END SUB
  375.  
  376. SUB ConnectSpouses (Start AS INTEGER, Last AS INTEGER) STATIC
  377. StartLI = IND(Start).Birth ' Line Person is ON
  378. EndLI = IND(Last).Birth    ' Line Person is ON
  379. IF StartLI < EndLI THEN
  380.    MID$(LI(StartLI).COL, 50, 1) = "─" '196
  381.    MID$(LI(EndLI).COL, 50, 1) = "─"   '196
  382.    COL = 49
  383.    DO WHILE (MID$(LI(StartLI).COL, COL, 1) <> " " AND COL > 1)
  384.       IF MID$(LI(StartLI).COL, COL, 1) = "│" THEN '179
  385.          MID$(LI(StartLI).COL, COL, 1) = "┼"      '197
  386.       END IF
  387.       MID$(LI(StartLI).COL, COL - 1, 1) = "─" '196
  388.       COL = COL - 2
  389.    LOOP
  390.    MID$(LI(StartLI).COL, COL, 1) = "┌"  '218
  391.  
  392.    IND(Start).Gen = StartLI     ' Row
  393.    IND(Start).Fam = COL         ' Column
  394.    IND(Last).Gen = StartLI      ' Row
  395.    IND(Last).Fam = COL          ' Column
  396.  
  397.    FOR L = (StartLI + 1) TO EndLI - 1
  398.      MID$(LI(L).COL, COL, 1) = "│" '179
  399.    NEXT L
  400.    MID$(LI(EndLI).COL, COL, 1) = "└"  '192
  401.    FOR C = (COL + 1) TO 49
  402.      IF MID$(LI(EndLI).COL, C, 1) = "│" THEN '179
  403.         MID$(LI(EndLI).COL, C, 1) = "┼" '197
  404.      ELSE
  405.         MID$(LI(EndLI).COL, C, 1) = "─" '196
  406.      END IF
  407.    NEXT C
  408. END IF
  409. END SUB
  410.  
  411. SUB ConvertDate (a$, year%, month%, day%, MODIFIER%, DYEAR%) STATIC
  412.     a1 = ASC(LEFT$(a$, 1))
  413.     a2 = ASC(MID$(a$, 2, 1))
  414.     a3 = ASC(MID$(a$, 3, 1))
  415.     a4 = ASC(MID$(a$, 4, 1))
  416.  
  417.     year% = a1 * 16 + INT(a2 / 16)
  418.     month% = (a2 - INT(a2 / 16) * 16) * 2 + INT(a3 / 128)
  419.     day% = INT((a3 - INT(a3 / 128) * 128) / 4)
  420.     MODIFIER% = a3 - INT(a3 / 4) * 4
  421.     IF a4 = 0 THEN
  422.        DYEAR% = 0
  423.     ELSE
  424.        DYEAR% = year% + a4
  425.     END IF
  426. END SUB
  427.  
  428. SUB DoParents (VP AS INTEGER) STATIC
  429. DIM Indi AS IndiRecord, Marr AS MarrRecord
  430. DIM I AS INTEGER
  431. DIM Start AS INTEGER, Finish AS INTEGER
  432. I = 1
  433. DO WHILE (I < VP + 2)
  434.    Start = LI(I).LRcd
  435.    IF Start > 0 THEN
  436.       GET #2, (Start + 1), Indi
  437.       IF Indi.IPMP > 0 THEN
  438.          GET #3, (Indi.IPMP + 1), Marr
  439.             IF Marr.MWifPtr > 0 THEN
  440.                Finish = Marr.MWifPtr
  441.             ELSE
  442.                Finish = Marr.MHusPtr
  443.             END IF
  444.          CALL ConnectFamily(Start, Finish)
  445.       END IF
  446.       DO WHILE (LI(I).LRcd <> 0)
  447.          I = I + 1
  448.       LOOP
  449.    END IF
  450.    I = I + 1
  451. LOOP
  452. END SUB
  453.  
  454. SUB DoSpouses (VP AS INTEGER) STATIC
  455. DIM Indi AS IndiRecord, Marr AS MarrRecord
  456. DIM CurrentIndi AS INTEGER
  457. FOR X = 1 TO VP
  458.   CurrentIndi = LI(X).RRcd
  459.    GET #2, (CurrentIndi + 1), Indi
  460.    ' Find all Spouses
  461.    IF Indi.IOMP > 0 THEN
  462.       GET #3, (Indi.IOMP + 1), Marr
  463.       IF Indi.ISEX = "M" THEN
  464.          CALL ConnectSpouses(CurrentIndi, Marr.MWifPtr)
  465.          DO WHILE (Marr.MHusOtherMarrPtr > 0)
  466.             GET #3, (Marr.MHusOtherMarrPtr + 1), Marr
  467.             CALL ConnectSpouses(CurrentIndi, Marr.MWifPtr)
  468.          LOOP
  469.       ELSE
  470.          CALL ConnectSpouses(CurrentIndi, Marr.MHusPtr)
  471.          DO WHILE (Marr.MWifOtherMarrPtr > 0)
  472.             GET #3, (Marr.MWifOtherMarrPtr + 1), Marr
  473.             CALL ConnectSpouses(CurrentIndi, Marr.MHusPtr)
  474.          LOOP
  475.       END IF
  476.    ELSE
  477.       IND(CurrentIndi).Gen = X ' Row
  478.       IND(Start).Fam = 49      ' Column
  479.    END IF
  480. NEXT X
  481. END SUB
  482.  
  483. SUB FindChildren (Child%) STATIC
  484.  SHARED IND() AS Location
  485.  SHARED PTR%
  486.  DIM Tindi AS IndiRecord
  487.    IF Child% > 0 THEN
  488.        CALL GenFam(Child%, -1)
  489.        GenAll% = IND(Child%).Gen
  490.        FamAll% = IND(Child%).Fam
  491.        GET #2, (Child% + 1), Tindi
  492.        DO WHILE (Child% > 0)
  493.           IND(Child%).SiblingCheck = "Y"
  494.           IND(Child%).Gen = GenAll%
  495.           IND(Child%).Fam = FamAll%
  496.           CALL Push(Child%)
  497.           Child% = Tindi.IOSP
  498.           IF Child% > 0 THEN
  499.              GET #2, (Child% + 1), Tindi
  500.           ELSE
  501.              EXIT DO
  502.           END IF
  503.        LOOP
  504.    END IF
  505.  
  506. END SUB
  507.  
  508. FUNCTION G2JD& (year%, month%, day%)
  509. T& = FIX((month% - 14) / 12)
  510. G2JD& = day% - 32075 + INT(1461 * (year% + 4800 + T&) / 4) + INT(367 * (month% - 2 - T& * 12) / 12) - INT(3 * INT((year% + 4900 + T&) / 100) / 4)
  511. END FUNCTION
  512.  
  513. SUB GenFam (RCD%, GenVar%) STATIC
  514.   SHARED IND() AS Location
  515.   SHARED FamNum%()
  516.   SHARED CurrentGen%
  517. IF RCD% > 0 THEN
  518.   IF IND(RCD%).Gen = 0 THEN
  519.      IND(RCD%).Gen = CurrentGen% + GenVar%
  520.   END IF
  521.  
  522.   IF IND(RCD%).Fam = 0 THEN
  523.      FamNum%(IND(RCD%).Gen) = FamNum%(IND(RCD%).Gen) + 1
  524.      IND(RCD%).Fam = FamNum%(IND(RCD%).Gen)
  525.   END IF
  526.  
  527. END IF
  528. END SUB
  529.  
  530. SUB GetName (NAMERCD%, Name$) STATIC
  531.    SHARED NameR AS NameRecord
  532.    IF NAMERCD% > 0 THEN
  533.       GET #1, (NAMERCD% + 1), NameR
  534.       Name$ = NameR.NNAME
  535.       lg% = INSTR(Name$, CHR$(0)) - 1
  536.       Name$ = LEFT$(Name$, lg%)
  537.       Name$ = Name$ + " "
  538.    ELSE
  539.       Name$ = ""
  540.    END IF
  541. END SUB
  542.  
  543. SUB MakeName (RCD AS INTEGER, Nam AS STRING) STATIC
  544. DIM Indi AS IndiRecord
  545. IF RCD > 0 THEN
  546.   GET #2, (RCD + 1), Indi
  547.   CALL GetName(Indi.ISUR, Surname$)
  548.   CALL GetName(Indi.IG1, Name1$)
  549.   CALL GetName(Indi.IG2, Name2$)
  550.   CALL GetName(Indi.IG3, Name3$)
  551.   Nam = RTRIM$(Surname$) + ", " + Name1$ + Name2$ + Name3$
  552. ELSE
  553.   Nam = " "
  554. END IF
  555. END SUB
  556.  
  557. SUB Pop (Dat%) STATIC
  558.   Dat% = Stack%(Tail)
  559.   IF Head = Tail THEN
  560.      Dat% = 0
  561.   END IF
  562.   Tail = Tail + 1
  563.   IF Tail > 1000 THEN
  564.      Tail = 0
  565.   END IF
  566. END SUB
  567.  
  568. SUB PrintIt STATIC
  569.  
  570. SHARED TotalCount
  571. 'first Pass
  572. Done = 1
  573. DO WHILE (Done = 1)
  574.    CurrentIndi = 1
  575.    Oldfam = IND(IPTR(CurrentIndi)).Fam
  576.    Oldgen = IND(IPTR(CurrentIndi)).Gen
  577.    FOR VP% = 1 TO 2000
  578.        IF Oldfam = IND(IPTR(CurrentIndi)).Fam THEN
  579.           IND(IPTR(CurrentIndi)).Birth = VP%
  580.           LI(VP%).RRcd = IPTR(CurrentIndi)
  581.           LI(VP%).FamCon = "│" '179
  582.           CurrentIndi = CurrentIndi + 1
  583.        ELSE
  584.           Oldfam = IND(IPTR(CurrentIndi)).Fam
  585.           LI(VP%).RRcd = 0
  586.           LI(VP%).FamCon = " "
  587.        END IF
  588.        LI(VP%).LRcd = 0
  589.        LI(VP%).COL = SPACE$(50)
  590.        IF Oldgen <> IND(IPTR(CurrentIndi)).Gen THEN
  591.           Oldgen = IND(IPTR(CurrentIndi)).Gen
  592.           Done = 0
  593.           EXIT DO
  594.        END IF
  595.    NEXT VP%
  596. LOOP
  597.    CALL DoSpouses(VP%)
  598.    CALL PrintLI(VP%)
  599.  
  600. 'PRINT "press a Key"
  601. 'DO
  602. 'LOOP WHILE INKEY$ = ""
  603. 'PRINT "OK"
  604.  
  605. 'The Rest off the Generations
  606. DO WHILE (CurrentIndi <= TotalCount)
  607.    Done = 1
  608.    DO WHILE (Done = 1)
  609.       OldVP% = VP%
  610.       FOR VN% = 1 TO VP% + 1
  611.         LI(VN%).LRcd = LI(VN%).RRcd
  612.         LI(VN%).RRcd = 0
  613.         LI(VN%).COL = SPACE$(50)
  614.         LI(VN%).FamCon = " "
  615.       NEXT VN%
  616.       FOR VN% = VP% TO 2000
  617.         LI(VN%).LRcd = 0
  618.         LI(VN%).RRcd = 0
  619.         LI(VN%).COL = SPACE$(50)
  620.         LI(VN%).FamCon = " "
  621.       NEXT VN%
  622.       FOR VP% = 1 TO 2000
  623.         IF Oldfam = IND(IPTR(CurrentIndi)).Fam THEN
  624.            IND(IPTR(CurrentIndi)).Birth = VP%
  625.            LI(VP%).RRcd = IPTR(CurrentIndi)
  626.            LI(VP%).FamCon = "│"  '179
  627.            CurrentIndi = CurrentIndi + 1
  628.         ELSE
  629.            Oldfam = IND(IPTR(CurrentIndi)).Fam
  630.            LI(VP%).RRcd = 0
  631.            LI(VP%).FamCon = " "
  632.         END IF
  633.         LI(VP%).COL = SPACE$(50)
  634.         IF Oldgen <> IND(IPTR(CurrentIndi)).Gen THEN
  635.            Oldgen = IND(IPTR(CurrentIndi)).Gen
  636.            Done = 0
  637.            EXIT DO
  638.         END IF
  639.       NEXT VP%
  640.    LOOP
  641.    CALL DoSpouses(VP%)
  642.    CALL DoParents(OldVP%)
  643.    IF OldVP% > VP% THEN
  644.       MaxVP% = OldVP%
  645.    ELSE
  646.       MaxVP% = VP%
  647.    END IF
  648.    CALL PrintLI(MaxVP%)
  649. '   PRINT "press a Key"
  650. '   DO
  651. '     LOOP WHILE INKEY$ = ""
  652. '     PRINT "OK"
  653. LOOP
  654. END SUB
  655.  
  656. SUB PrintLI (VP%) STATIC
  657. 'lprint CHR$(12)
  658. PRINT #8, "=============================================================================="
  659. FOR X = 1 TO VP%
  660.   CALL MakeName(LI(X).RRcd, Rname$)
  661.   PRINT #8, USING LFMT; LI(X).COL; Rname$; LI(X).FamCon
  662. NEXT X
  663.  
  664. END SUB
  665.  
  666. SUB Push (Dat%) STATIC
  667. IF Dat% > 0 THEN
  668.   IF IND(Dat%).Processed <> "Y" THEN
  669.      Stack%(Head) = Dat%
  670.      Head = Head + 1
  671.      IF Head > 1000 THEN Head = 0
  672.      IF Head = Tail THEN
  673.         PRINT "Head Caught Tail - Increase Stack Size "
  674.         STOP
  675.      END IF
  676.   END IF
  677. END IF
  678. END SUB
  679.  
  680. SUB SortInd STATIC
  681. SHARED IND() AS Location, TotalCount, IPTR() AS INTEGER
  682.  First% = 1
  683.  DO WHILE (FamNum%(First%) = 0)
  684.     First% = First% + 1
  685.  LOOP
  686.  First% = First% - 1
  687.  
  688. CLS
  689. PRINT "Building Keys..."
  690. FOR X% = 1 TO TotalCount
  691.   IND(X%).Gen = IND(X%).Gen - First%
  692.   MID$(IND(X%).Index, 1, 2) = RIGHT$("000" + LTRIM$(STR$(IND(X%).Gen)), 2)
  693.   MID$(IND(X%).Index, 3, 3) = RIGHT$("000" + LTRIM$(STR$(IND(X%).Fam)), 3)
  694.   MID$(IND(X%).Index, 6, 7) = RIGHT$("000" + LTRIM$(STR$(IND(X%).Birth)), 7)
  695.   IPTR(X%) = X%
  696. NEXT X%
  697.         
  698.   
  699.    CLS
  700.    PRINT "Sorting 1st group"
  701.    Offset = TotalCount \ 2
  702.    DO WHILE Offset > 0
  703.       Limit = TotalCount - Offset
  704.       DO
  705.          Switch = 0
  706.          FOR I = 1 TO Limit
  707.             IF IND(IPTR(I)).Index > IND(IPTR(I + Offset)).Index THEN
  708.                SWAP IPTR(I), IPTR(I + Offset)
  709.                Switch = I
  710.             END IF
  711.          NEXT I
  712.          Limit = Switch
  713.       LOOP WHILE Switch
  714.       Offset = Offset \ 2
  715.       PRINT Offset; "   "
  716.    LOOP
  717. END SUB
  718.  
  719.